home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / emacs / emacs1857 / src_d2.zoo / source / eval.c < prev    next >
C/C++ Source or Header  |  1991-12-02  |  56KB  |  2,154 lines
  1. /* Evaluator for GNU Emacs Lisp interpreter.
  2.    Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20.  
  21. #include "config.h"
  22. #include "lisp.h"
  23.  
  24. #ifndef standalone
  25. #include "commands.h"
  26. #else
  27. #define FROM_KBD 1
  28. #endif
  29.  
  30. #include <setjmp.h>
  31.  
  32. /* This definition is duplicated in alloc.c and keyboard.c */
  33. /* Putting it in lisp.h makes cc bomb out! */
  34.  
  35. struct backtrace
  36.   {
  37.     struct backtrace *next;
  38.     Lisp_Object *function;
  39.     Lisp_Object *args;    /* Points to vector of args. */
  40.     int nargs;        /* length of vector */
  41.            /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
  42.     char evalargs;
  43.     /* Nonzero means call value of debugger when done with this operation. */
  44.     char debug_on_exit;
  45.   };
  46.  
  47. struct backtrace *backtrace_list;
  48.  
  49. struct catchtag
  50.   {
  51.     Lisp_Object tag;
  52.     Lisp_Object val;
  53.     struct catchtag *next;
  54.     struct gcpro *gcpro;
  55.     jmp_buf jmp;
  56.     struct backtrace *backlist;
  57.     int lisp_eval_depth;
  58.     int pdlcount;
  59.     int poll_suppress_count;
  60.   };
  61.  
  62. struct catchtag *catchlist;
  63.  
  64. Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
  65. Lisp_Object Vquit_flag, Vinhibit_quit, Qinhibit_quit;
  66. Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
  67. Lisp_Object Qand_rest, Qand_optional;
  68.  
  69. /* Non-nil means record all fset's and provide's, to be undone
  70.    if the file being autoloaded is not fully loaded.
  71.    They are recorded by being consed onto the front of Vautoload_queue:
  72.    (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide.  */
  73.  
  74. Lisp_Object Vautoload_queue;
  75.  
  76. /* Current number of specbindings allocated in specpdl.  */
  77.  
  78. int specpdl_size;
  79.  
  80. /* Pointer to beginning of specpdl.  */
  81.  
  82. struct specbinding *specpdl;
  83.  
  84. /* Pointer to first unused element in specpdl.  */
  85.  
  86. struct specbinding *specpdl_ptr;
  87.  
  88. /* Maximum size allowed for specpdl allocation */
  89.  
  90. int max_specpdl_size;
  91.  
  92. /* Depth in Lisp evaluations and function calls.  */
  93.  
  94. int lisp_eval_depth;
  95.  
  96. /* Maximum allowed depth in Lisp evaluations and function calls.  */
  97.  
  98. int max_lisp_eval_depth;
  99.  
  100. /* Nonzero means enter debugger before next function call */
  101. int debug_on_next_call;
  102.  
  103. /* Nonzero means display a backtrace if an error
  104.  is handled by the command loop's error handler. */
  105. int stack_trace_on_error;
  106.  
  107. /* Nonzero means enter debugger if an error
  108.  is handled by the command loop's error handler. */
  109. int debug_on_error;
  110.  
  111. /* Nonzero means enter debugger if a quit signal
  112.  is handled by the command loop's error handler. */
  113. int debug_on_quit;
  114.  
  115. Lisp_Object Vdebugger;
  116.  
  117. void specbind (), unbind_to (), record_unwind_protect ();
  118.  
  119. Lisp_Object funcall_lambda ();
  120. extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
  121.  
  122. init_eval_once ()
  123. {
  124.   specpdl_size = 50;
  125.   specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
  126.   max_specpdl_size = 600;
  127.   max_lisp_eval_depth = 200;
  128. }
  129.  
  130. init_eval ()
  131. {
  132.   specpdl_ptr = specpdl;
  133.   catchlist = 0;
  134.   handlerlist = 0;
  135.   backtrace_list = 0;
  136.   Vquit_flag = Qnil;
  137.   debug_on_next_call = 0;
  138.   lisp_eval_depth = 0;
  139. }
  140.  
  141. Lisp_Object
  142. call_debugger (arg)
  143.      Lisp_Object arg;
  144. {
  145.   if (lisp_eval_depth + 20 > max_lisp_eval_depth)
  146.     max_lisp_eval_depth = lisp_eval_depth + 20;
  147.   if (specpdl_size + 40 > max_specpdl_size)
  148.     max_specpdl_size = specpdl_size + 40;
  149.   debug_on_next_call = 0;
  150.   return apply1 (Vdebugger, arg);
  151. }
  152.  
  153. do_debug_on_call (code)
  154.      Lisp_Object code;
  155. {
  156.   debug_on_next_call = 0;
  157.   backtrace_list->debug_on_exit = 1;
  158.   call_debugger (Fcons (code, Qnil));
  159. }
  160.  
  161. /* NOTE!!! Every function that can call EVAL must protect its args
  162.  and temporaries from garbage collection while it needs them.
  163.  The definition of `For' shows what you have to do.  */
  164.  
  165. DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
  166.   "Eval args until one of them yields non-NIL, then return that value.\n\
  167. The remaining args are not evalled at all.\n\
  168. If all args return NIL, return NIL.")
  169.   (args)
  170.      Lisp_Object args;
  171. {
  172.   register Lisp_Object val;
  173.   Lisp_Object args_left;
  174.   struct gcpro gcpro1;
  175.  
  176.   if (NULL(args))
  177.     return Qnil;
  178.  
  179.   args_left = args;
  180.   GCPRO1 (args_left);
  181.  
  182.   do
  183.     {
  184.       val = Feval (Fcar (args_left));
  185.       if (!NULL (val))
  186.     break;
  187.       args_left = Fcdr (args_left);
  188.     }
  189.   while (!NULL(args_left));
  190.  
  191.   UNGCPRO;
  192.   return val;
  193. }
  194.  
  195. DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
  196.   "Eval args until one of them yields NIL, then return NIL.\n\
  197. The remaining args are not evalled at all.\n\
  198. If no arg yields NIL, return the last arg's value.")
  199.   (args)
  200.      Lisp_Object args;
  201. {
  202.   register Lisp_Object val;
  203.   Lisp_Object args_left;
  204.   struct gcpro gcpro1;
  205.  
  206.   if (NULL(args))
  207.     return Qt;
  208.  
  209.   args_left = args;
  210.   GCPRO1 (args_left);
  211.  
  212.   do
  213.     {
  214.       val = Feval (Fcar (args_left));
  215.       if (NULL (val))
  216.     break;
  217.       args_left = Fcdr (args_left);
  218.     }
  219.   while (!NULL(args_left));
  220.  
  221.   UNGCPRO;
  222.   return val;
  223. }
  224.  
  225. DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
  226.   "(if C T E...) if C yields non-NIL do T, else do E...\n\
  227. Returns the value of T or the value of the last of the E's.\n\
  228. There may be no E's; then if C yields NIL, the value is NIL.")
  229.   (args)
  230.      Lisp_Object args;
  231. {
  232.   register Lisp_Object cond;
  233.   struct gcpro gcpro1;
  234.  
  235.   GCPRO1 (args);
  236.   cond = Feval (Fcar (args));
  237.   UNGCPRO;
  238.  
  239.   if (!NULL (cond))
  240.     return Feval (Fcar (Fcdr (args)));
  241.   return Fprogn (Fcdr (Fcdr (args)));
  242. }
  243.  
  244. DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
  245.   "(cond CLAUSES...) tries each clause until one succeeds.\n\
  246. Each clause looks like (C BODY...).  C is evaluated\n\
  247. and, if the value is non-nil, this clause succeeds:\n\
  248. then the expressions in BODY are evaluated and the last one's\n\
  249. value is the value of the cond expression.\n\
  250. If a clause looks like (C), C's value if non-nil is returned from cond.\n\
  251. If no clause succeeds, cond returns nil.")
  252.   (args)
  253.      Lisp_Object args;
  254. {
  255.   register Lisp_Object clause, val;
  256.   struct gcpro gcpro1;
  257.  
  258.   GCPRO1 (args);
  259.   while (!NULL (args))
  260.     {
  261.       clause = Fcar (args);
  262.       val = Feval (Fcar (clause));
  263.       if (!NULL (val))
  264.     {
  265.       if (!EQ (XCONS (clause)->cdr, Qnil))
  266.         val = Fprogn (XCONS (clause)->cdr);
  267.       break;
  268.     }
  269.       args = XCONS (args)->cdr;
  270.     }
  271.   UNGCPRO;
  272.  
  273.   return val;
  274. }
  275.  
  276. DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
  277.   "Eval arguments in sequence, and return the value of the last one.")
  278.   (args)
  279.      Lisp_Object args;
  280. {
  281.   register Lisp_Object val, tem;
  282.   Lisp_Object args_left;
  283.   struct gcpro gcpro1;
  284.  
  285.   /* In Mocklisp code, symbols at the front of the progn arglist
  286.    are to be bound to zero. */
  287.   if (!EQ (Vmocklisp_arguments, Qt))
  288.     {
  289.       val = make_number (0);
  290.       while (!NULL (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
  291.     {
  292.       QUIT;
  293.       specbind (tem, val), args = Fcdr (args);
  294.     }
  295.     }
  296.  
  297.   if (NULL(args))
  298.     return Qnil;
  299.  
  300.   args_left = args;
  301.   GCPRO1 (args_left);
  302.  
  303.   do
  304.     {
  305.       val = Feval (Fcar (args_left));
  306.       args_left = Fcdr (args_left);
  307.     }
  308.   while (!NULL(args_left));
  309.  
  310.   UNGCPRO;
  311.   return val;
  312. }
  313.  
  314. DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
  315.   "Eval arguments in sequence, then return the FIRST arg's value.\n\
  316. This value is saved during the evaluation of the remaining args,\n\
  317. whose values are discarded.")
  318.   (args)
  319.      Lisp_Object args;
  320. {
  321.   Lisp_Object val;
  322.   register Lisp_Object args_left;
  323.   struct gcpro gcpro1, gcpro2;
  324.   register int argnum = 0;
  325.  
  326.   if (NULL(args))
  327.     return Qnil;
  328.  
  329.   args_left = args;
  330.   val = Qnil;
  331.   GCPRO2 (args, val);
  332.  
  333.   do
  334.     {
  335.       if (!(argnum++))
  336.         val = Feval (Fcar (args_left));
  337.       else
  338.     Feval (Fcar (args_left));
  339.